home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue60 / System / MainForm.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-06-28  |  4.9 KB  |  158 lines
  1. unit MainForm;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, Buttons, ComCtrls, WinINet, ExtCtrls;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     FileList: TListView;
  12.     GetFileListButton: TButton;
  13.     CurrentDir: TLabel;
  14.     Panel1: TPanel;
  15.     Status: TLabel;
  16.     UpButton: TButton;
  17.     procedure GetFileListButtonClick(Sender: TObject);
  18.     procedure FileListDblClick(Sender: TObject);
  19.     procedure UpButtonClick(Sender: TObject);
  20.     procedure FileListCompare(Sender: TObject; Item1, Item2: TListItem;
  21.       Data: Integer; var Compare: Integer);
  22.   private
  23.     { Private declarations }
  24.     hSession: HInternet;
  25.     hFTP: HInternet;
  26.     hFind: HInternet;
  27.     ThisDir: String;
  28.     procedure GetFileList (const Dir: String);
  29.   public
  30.     { Public declarations }
  31.   end;
  32.  
  33. var
  34.   Form1: TForm1;
  35.  
  36. implementation
  37.  
  38. {$R *.DFM}
  39.  
  40. procedure MyCallBack (hHandle: HINTERNET; Self: TForm1; dwStatus: DWord; pStatus: Pointer; dwLen: DWord); stdcall;
  41. var
  42.     ErrNum, BuffSize: DWord;
  43.     szBuff: array [0..1024] of Char;
  44. begin
  45.     BuffSize := sizeof (szBuff);
  46.     if InternetGetLastResponseInfo (ErrNum, szBuff, BuffSize) then
  47.         if (BuffSize > 0) and (szBuff [0] <> #0) then
  48.             Self.Status.Caption := szBuff;
  49. end;
  50.  
  51. procedure TForm1.GetFileList (const Dir: String);
  52. var
  53.     Item: TListItem;
  54.     szDirSize: Cardinal;
  55.     FileData: TWin32FindData;
  56.     szDirectory: array [0..512] of Char;
  57. begin
  58.     Screen.Cursor := crHourGlass;
  59.     try
  60.         hFTP := InternetConnect (hSession, 'ftp.microsoft.com',
  61.                                      Internet_Default_FTP_Port, Nil, Nil,
  62.                                      Internet_Service_FTP, 0, Cardinal (Self));
  63.         if hFTP <> Nil then try
  64.  
  65.             InternetSetStatusCallback (hFTP, @MyCallback);
  66.             Status.Caption := 'Connected to ftp.microsoft.com';
  67.  
  68.             if Dir <> '' then FtpSetCurrentDirectory (hFTP, PChar (Dir));
  69.  
  70.             // Get current directory
  71.             szDirSize := sizeof (szDirectory);
  72.             if FtpGetCurrentDirectory (hFTP, szDirectory, szDirSize) then begin
  73.                 ThisDir := szDirectory;
  74.                 CurrentDir.Caption := 'Current Directory = ' + szDirectory;
  75.             end;
  76.  
  77.             // The main enumeration loop
  78.             FileList.Items.Clear;
  79.             hFind := FtpFindFirstFile (hFTP, '*.*', FileData, 0, Cardinal (Self));
  80.             if hFind <> Nil then try
  81.                 while True do begin
  82.                     if GetLastError = Error_No_More_Files then break;
  83.                     // We've got a file
  84.                     Item := FileList.Items.Add;
  85.                     Item.Caption := FileData.cFileName;
  86.                     // Is this a directory or a file?
  87.                     if FileData.dwFileAttributes = File_Attribute_Directory then begin
  88.                         Item.Data := Pointer (1);
  89.                         Item.SubItems.Add ('--dir--');
  90.                     end else begin
  91.                         Item.Data := Nil;
  92.                         Item.SubItems.Add (IntToStr (FileData.nFileSizeLow));
  93.                     end;
  94.  
  95.                     if not InternetFindNextFile (hFind, @FileData) then break;
  96.                 end;
  97.             finally
  98.                 InternetCloseHandle (hFind);
  99.             end;
  100.         finally
  101.             InternetCloseHandle (hFTP);
  102.         end;
  103.     finally
  104.         Screen.Cursor := crDefault;
  105.     end;
  106. end;
  107.  
  108. procedure TForm1.GetFileListButtonClick (Sender: TObject);
  109. begin
  110.     hSession := InternetOpen ('DelphiMagWinINetDemo', Internet_Open_Type_PreConfig, Nil, Nil, 0);
  111.     if hSession <> Nil then try
  112.         GetFileList (ThisDir);
  113.     finally
  114.         InternetCloseHandle (hSession);
  115.     end;
  116. end;
  117.  
  118. procedure TForm1.FileListDblClick(Sender: TObject);
  119. var
  120.     Item: TListItem;
  121.     NewDir: String;
  122. begin
  123.     // Is this a directory double-click?
  124.     Item := FileList.Selected;
  125.     if (Item <> Nil) and (Item.Data <> Nil) then begin
  126.         NewDir := ThisDir;
  127.         if NewDir = '' then NewDir := '/';
  128.         if NewDir [Length (NewDir)] <> '/' then NewDir := NewDir + '/';
  129.         ThisDir := NewDir + Item.Caption;
  130.         GetFileListButtonClick (Sender);
  131.     end;
  132. end;
  133.  
  134. procedure TForm1.UpButtonClick(Sender: TObject);
  135. var
  136.     p: PChar;
  137.     NewDir: array [0..512] of Char;
  138. begin
  139.     if (ThisDir <> '') and (ThisDir <> '/') then begin
  140.         StrPCopy (NewDir, ThisDir);
  141.         p := StrRScan (NewDir, '/');
  142.         if p <> Nil then begin
  143.             p^ := #0;
  144.             ThisDir := NewDir;
  145.             if ThisDir = '' then ThisDir := '/';
  146.             GetFileListButtonClick (Sender);
  147.         end;
  148.     end;
  149. end;
  150.  
  151. procedure TForm1.FileListCompare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer);
  152. begin
  153.     Compare := Ord (Ord (Item1.Data <> Nil) < Ord (Item2.Data <> Nil));
  154. end;
  155.  
  156. end.
  157.  
  158.